.

original commit: 45b2a230f7d16b64c28d579c3267679f349083d6

collects/mzlib/etc.ss

@@ -508,6 +508,7 @@
                   (hash-table-put! ht key val) ...
                   ht)))]
            [_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))
+    
 
   (define-syntax (begin-with-definitions stx)
     ;; Body can have mixed exprs and defns. Wrap expressions with

collects/mzlib/struct.ss

@@ -0,0 +1,58 @@
+
+(module struct mzscheme
+  (provide copy-struct)
+
+  (require-for-syntax (lib "struct.ss" "syntax")
+		      (lib "stx.ss" "syntax"))
+
+  (define-syntax (copy-struct stx)
+    (syntax-case stx ()
+      [(_ info structure (accessor-name new-val) ...)
+       (let ([ans (syntax->list  #'((accessor-name new-val) ...))])
+	 (unless (identifier? #'info)
+	   (raise-syntax-error #f "not an identifier for structure type" stx #'info))
+	 (for-each (lambda (an)
+		     (unless (identifier? (stx-car an))
+		       (raise-syntax-error #f "not an identifier for accessor name" stx (stx-car an))))
+		   ans)
+	 
+	 ;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
+	 (let ((new-binding-for 
+		(lambda (f)
+		  (ormap (lambda (x) 
+			   (if (eq? (syntax-object->datum (stx-car x)) (syntax-object->datum f)) 
+			       (cadr (syntax-e x)) 
+			       #f))
+			 ans))))
+	   
+	   (let-values ([(construct pred accessors)
+			 (let ([v (syntax-local-value #'info (lambda () #f))])
+			   (unless (struct-declaration-info? v)
+			     (raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
+			   (values (cadr v)
+				   (caddr v)
+				   (cadddr v)))]
+			[(as) (map (lambda (an) (stx-car an)) ans)])
+	     (for-each 
+	      (lambda (field)
+		(unless (ormap (lambda (f2) (module-or-top-identifier=? field f2)) accessors)
+		  (raise-syntax-error #f "accessor name not associated with the given structure type" stx field)))
+	      as)
+	     
+	     (let ((dupe (check-duplicate-identifier as)))
+	       (when dupe 
+		 (raise-syntax-error #f 
+				     "duplicate field assignment" 
+				     stx 
+				     dupe)))
+	     
+	     ;; the actual result
+	     #`(let ((the-struct structure))
+		 (if (#,pred the-struct)
+		     (#,construct
+		      #,@(map 
+			  (lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
+			  (reverse accessors)))
+		     (raise-type-error '_  #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))])))
+
+