From b88f13ef4a19e10c5dc56e388f02ff653b182f48 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Sat, 18 Jun 2016 23:02:25 +0900
Subject: [PATCH] preserving hygienie in define-record-type

---
 lib/srfi/9.scm | 23 +++++++++++++----------
 1 file changed, 13 insertions(+), 10 deletions(-)

diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm
index d8f38377..2e169197 100644
--- a/lib/srfi/9.scm
+++ b/lib/srfi/9.scm
@@ -16,13 +16,14 @@
             (_let (rename 'let))
             (_register (rename 'register-simple-type))
             (_slot-set! (rename 'slot-set!))
-            (_type_slot_offset (rename 'type-slot-offset)))
+            (_type_slot_offset (rename 'type-slot-offset))
+            (q (rename 'syntax-quote)))
        ;; catch a common mistake
        (if (eq? name make)
            (error "same binding for record rtd and constructor" name))
        `(,(rename 'begin)
          ;; type
-         (,_define ,name (,_register ,name-str ,parent ',(map car fields)))
+         (,_define ,name (,_register ,name-str ,parent (,q ,(map car fields))))
          ;; predicate
          (,_define ,pred (,(rename 'make-type-predicate)
                           ,(symbol->string (identifier->symbol pred))
@@ -35,7 +36,7 @@
                            ,(symbol->string
                              (identifier->symbol (cadr f)))
                            ,name
-                           (,_type_slot_offset ,name ',(car f))))))
+                           (,_type_slot_offset ,name (,q ,(car f)))))))
                 fields)
          ,@(map (lambda (f)
                   (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
@@ -44,7 +45,7 @@
                            ,(symbol->string
                              (identifier->symbol (car (cddr f))))
                            ,name
-                           (,_type_slot_offset ,name ',(car f))))))
+                           (,_type_slot_offset ,name (,q ,(car f)))))))
                 fields)
          ;; constructor
          (,_define ,make
@@ -59,14 +60,16 @@
                        ,@sets
                        res))))
                (else
-                (let ((field (assq (car ls) fields)))
+                (let lp2 ((f fields))
                   (cond
-                   ((not field)
-                    (error "unknown record field in constructor" (car ls)))
-                   ((pair? (cddr field))
+                   ((null? f)
+                    (error "unknown record field in constructor" (car ls) fields))
+                   ((not (compare (car ls) (caar f)))
+                    (lp2 (cdr f)))
+                   ((pair? (cddr (car f)))
                     (lp (cdr ls)
-                        (cons `(,(car (cddr field)) res ,(car ls)) sets)))
+                        (cons `(,(car (cddr (car f))) res ,(car ls)) sets)))
                    (else
                     (lp (cdr ls)
-                        (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
+                        (cons `(,_slot-set! ,name res (,_type_slot_offset ,name (,q ,(car ls))) ,(car ls))
                               sets))))))))))))))