From fbac4e75fd3cb3ba9908165072130092079888b1 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 3 Apr 2008 15:10:07 +0000
Subject: [PATCH] fix r6rs quasisyntax

svn: r9150
---
 collects/r6rs/private/qq-gen.ss | 8 +++++---
 collects/rnrs/base-6.ss         | 2 +-
 collects/rnrs/syntax-case-6.ss  | 2 +-
 3 files changed, 7 insertions(+), 5 deletions(-)

diff --git a/collects/r6rs/private/qq-gen.ss b/collects/r6rs/private/qq-gen.ss
index 5851794d82..583562740e 100644
--- a/collects/r6rs/private/qq-gen.ss
+++ b/collects/r6rs/private/qq-gen.ss
@@ -7,7 +7,7 @@
 (provide define-generalized-qq)
 
 (define-syntax-rule (define-generalized-qq r6rs:quasiquote 
-                      quasiquote unquote unquote-splicing)
+                      quasiquote unquote unquote-splicing uq-wrap)
   (...
    (define-syntax (r6rs:quasiquote stx)
      ;; Replace (unquote expr ...) with (unquote expr) ...
@@ -23,7 +23,8 @@
                     (let ([new-rest (loop #'rest level)])
                       (if (zero? level)
                           (if (and (eq? new-rest #'rest)
-                                   (= 1 (length (syntax->list #'(expr ...)))))
+                                   (= 1 (length (syntax->list #'(expr ...))))
+                                   (free-identifier=? #'uq-wrap #'values))
                               tmpl
                               (datum->syntax
                                tmpl
@@ -32,7 +33,8 @@
                                                 (datum->syntax
                                                  a
                                                  (list (car (syntax-e a))
-                                                       expr)
+                                                       (list (syntax uq-wrap)
+                                                             expr))
                                                  a a a))
                                               (syntax->list #'(expr ...))))
                                        new-rest)
diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss
index f73a2a9800..e28dafc090 100644
--- a/collects/rnrs/base-6.ss
+++ b/collects/rnrs/base-6.ss
@@ -361,7 +361,7 @@
 ;; quasiquote generalization
 
 (define-generalized-qq r6rs:quasiquote 
-  r5rs:quasiquote unquote unquote-splicing)
+  r5rs:quasiquote unquote unquote-splicing values)
 
 ;; ----------------------------------------
 ;; let[*]-values
diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss
index 09f094eeea..f5bab60504 100644
--- a/collects/rnrs/syntax-case-6.ss
+++ b/collects/rnrs/syntax-case-6.ss
@@ -275,4 +275,4 @@
        [(p ...) (let () e1 e2 ...)])]))
 
 (define-generalized-qq r6rs:quasisyntax
-  quasisyntax unsyntax unyntaxquote-splicing)
+  quasisyntax unsyntax unsyntax-splicing convert-mpairs)