~ chicken-core (chicken-5) 727b2b3fea271474540f215af4842d32e82e7e6d

commit 727b2b3fea271474540f215af4842d32e82e7e6d
Author:     felix <felix@y.(none)>
AuthorDate: Sun Aug 22 23:22:10 2010 +0200
Commit:     felix <felix@y.(none)>
CommitDate: Sun Aug 22 23:22:10 2010 +0200

    applied zbigniew's record-rename patch (finally), added test-case

diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 4fc2fcf8..f97c22a1 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -59,8 +59,11 @@
   (lambda (x r c)
     (##sys#check-syntax 'define-record x '(_ symbol . #(symbol 0)))
     (let* ((name (cadr x))
-	   (slots (cddr x))
 	   (prefix (symbol->string name))
+	   (name (if (##sys#current-module)
+		     (##sys#module-rename name (##sys#module-name (##sys#current-module)))
+		     name))
+	   (slots (cddr x))
 	   (setters (memq #:record-setters ##sys#features))
 	   (%define (r 'define))
 	   (%getter-with-setter (r 'getter-with-setter)))
@@ -822,11 +825,21 @@
 	      'define-record-printer (cons head body)
 	      '((symbol symbol symbol) . #(_ 1)))
 	     `(##sys#register-record-printer 
-	       ',(##sys#slot head 0)
+	       ',(if (##sys#current-module)
+		     (##sys#module-rename (##sys#slot head 0)
+					  (##sys#module-name
+					   (##sys#current-module)))
+		     (##sys#slot head 0))
 	       (##core#lambda ,(##sys#slot head 1) ,@body)) ]
-	    [else
+	    (else
 	     (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
-	     `(##sys#register-record-printer ',head ,@body) ] ) ))))
+	     `(##sys#register-record-printer
+               ',(if (##sys#current-module)
+                     (##sys#module-rename head
+                                          (##sys#module-name
+                                           (##sys#current-module)))
+                     head)
+               ,@body) ) ) ))))
 
 
 ;;; Exceptions:
@@ -897,7 +910,11 @@
      'define-record-type 
      form
      '(_ variable #(variable 1) variable . _)) 
-    (let* ((t (cadr form))
+    (let* ((t (if (##sys#current-module)
+		     (##sys#module-rename (cadr form)
+					  (##sys#module-name
+					   (##sys#current-module)))
+		     (cadr form)))
 	   (conser (caddr form))
 	   (pred (cadddr form))
 	   (slots (cddddr form))
diff --git a/distribution/manifest b/distribution/manifest
index 6c2ceb82..9d12d6d9 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -100,6 +100,7 @@ tests/compiler-tests-2.scm
 tests/compiler-tests-3.scm
 tests/inlining-tests.scm
 tests/locative-stress-test.scm
+tests/record-rename-test.scm
 tests/r4rstest.scm
 tests/null.scm
 tests/sgrep.scm
diff --git a/tests/record-rename-test.scm b/tests/record-rename-test.scm
new file mode 100644
index 00000000..5a3e2ef6
--- /dev/null
+++ b/tests/record-rename-test.scm
@@ -0,0 +1,33 @@
+;;;; record-rename-test.scm
+
+
+(define-record foo a)
+
+(define-record-type bar
+  (make-bar x)
+  bar?
+  (x get-x))
+
+
+(module m1 (make-foo make-bar)
+(import scheme chicken)
+
+(define-record foo a b)
+
+(define-record-type bar
+  (make-bar x y)
+  bar?
+  (x get-x) (y get-y))
+
+)
+
+
+(let ((f1 (make-foo 1))
+      (f2 (make-bar 2)))
+  (print (list f1 f2)))
+
+(import m1)
+
+(let ((f1 (make-foo 1 2))
+      (f2 (make-bar 3 4)))
+  (print (list f1 f2)))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index e2c2eab6..a17184fc 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -221,6 +221,9 @@ echo "======================================== posix tests ..."
 $compile posix-tests.scm
 ./a.out
 
+echo "======================================== record-renaming tests ..."
+$interpret -bnq record-rename-test.scm
+
 echo "======================================== regular expression tests ..."
 $interpret -bnq test-irregex.scm
 $interpret -bnq test-glob.scm