=== modified file '%3a99/records/syntactic.sls'
--- %3a99/records/syntactic.sls	2009-03-18 03:00:38 +0000
+++ %3a99/records/syntactic.sls	2009-11-04 08:19:12 +0000
@@ -39,12 +39,68 @@
 
   (define-syntax define-record-type-helper0
     (lambda (x)
+
+      ; Given syntax objects, passes them to helper macro.
+
+      (define (construct-record-type-definitions
+               tname fields parent cspec pred afields mfields)
+        (let ()
+
+          (define (frob x)
+            (cond ((identifier? x)
+                   x)
+                  ((pair? x)
+                   (cons (frob (car x)) (frob (cdr x))))
+                  ((vector? x)
+                   (vector-map frob x))
+                  (else
+                   (datum->syntax tname x))))
+
+          #`(#,(frob #'define-record-type-helper)
+             #,(frob tname)
+             #,(frob fields)
+             #,(frob parent)
+             #,(frob cspec)
+             #,(frob pred)
+             #,(frob afields)
+             #,(frob mfields))))
+
+      ; Given a syntax object that represents a non-empty list,
+      ; returns the syntax object for its first element.
+
+      (define (syntax-car x)
+        (syntax-case x ()
+         ((x0 x1 ...)
+          #'x0)))
+
+      ; Given a syntax object that represents a non-empty list,
+      ; returns the syntax object obtained by omitting the first
+      ; element of that list.
+
+      (define (syntax-cdr x)
+        (syntax-case x ()
+         ((x0 x1 ...)
+          #'(x1 ...))))
+
+      ; Given a syntax object that represents a non-empty list,
+      ; returns the corresponding list of syntax objects.
+
+      (define (syntax->list x)
+        (syntax-case x ()
+         (()
+          '())
+         ((x0 . x1)
+          (cons #'x0 (syntax->list #'x1)))))
+
       (define (complain)
         (syntax-violation 'define-record-type "illegal syntax" x))
+
+      ; tname is always identifier here.
+
       (syntax-case x ()
        ((_ tname pname constructor-spec predicate-spec . field-specs)
         (let* ((type-name (syntax->datum #'tname))
-               (parent (syntax->datum #'pname))
+               (parent-name (syntax->datum #'pname))
                (cspec (syntax->datum #'constructor-spec))
                (pspec (syntax->datum #'predicate-spec))
                (fspecs (syntax->datum #'field-specs))
@@ -54,32 +110,41 @@
                        (symbol->string type-name)))
                (constructor-name
                 (cond ((eq? cspec #f)
-                       #f)
+                       #'constructor-spec)
                       ((eq? cspec #t)
-                       (string->symbol
-                        (string-append "make-" type-name-string)))
+                       (datum->syntax
+                        #'tname
+                        (string->symbol
+                         (string-append "make-" type-name-string))))
                       ((symbol? cspec)
-                       cspec)
-                      ((pair? cspec)
-                       (car cspec))
+                       #'constructor-spec)
+                      ((and (pair? cspec) (symbol? (car cspec)))
+                       (syntax-car #'constructor-spec))
                       (else (complain))))
                (constructor-args
                 (cond ((pair? cspec)
                        (if (not (for-all symbol? cspec))
                            (complain)
-                           (list->vector (cdr cspec))))
+                           (list->vector
+                            (syntax->list (syntax-cdr #'constructor-spec)))))
                       (else #f)))
+               (new-constructor-spec
+                (if constructor-args
+                    (list constructor-name constructor-args)
+                    constructor-name))
                (predicate-name
                 (cond ((eq? pspec #f)
-                       #f)
+                       #'predicate-spec)
                       ((eq? pspec #t)
-                       (string->symbol
-                        (string-append type-name-string "?")))
+                       (datum->syntax
+                        #'tname
+                        (string->symbol
+                         (string-append type-name-string "?"))))
                       ((symbol? pspec)
-                       pspec)
+                       #'predicate-spec)
                       (else (complain))))
                (field-specs
-                (map (lambda (fspec)
+                (map (lambda (fspec field-spec)
                        (cond ((symbol? fspec)
                               (list 'immutable
                                     fspec
@@ -111,11 +176,16 @@
                              ((null? (cddr fspec))
                               (list 'immutable
                                     (car fspec)
-                                    (cadr fspec)))
+                                    (syntax-car (syntax-cdr field-spec))))
                              ((null? (cdddr fspec))
-                              (cons 'mutable fspec))
+                              (list 'mutable
+                                    (car fspec)
+                                    (syntax-car (syntax-cdr field-spec))
+                                    (syntax-car (syntax-cdr
+                                                 (syntax-cdr field-spec)))))
                              (else (complain))))
-                     fspecs))
+                     fspecs
+                     (syntax->list #'field-specs)))
 
                (fields (list->vector (map cadr field-specs)))
 
@@ -129,15 +199,14 @@
                      (filter (lambda (x) (= (length x) 4))
                              field-specs))))
 
-          (datum->syntax
+          (construct-record-type-definitions
            #'tname
-           `(,#'define-record-type-helper
-             ,type-name ,fields ,parent
-             ,(if constructor-args
-                  (list constructor-name constructor-args)
-                  constructor-name)
-             ,predicate-name
-             ,accessor-fields ,mutator-fields)))))))
+           fields
+           parent-name
+           new-constructor-spec
+           predicate-name
+           accessor-fields
+           mutator-fields))))))
 
   (define-syntax define-record-type-helper
     (syntax-rules ()