From f663307252c9a396b4e130ac4bd33b02c0f97e6c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 17 Sep 2010 16:29:15 -0600
Subject: [PATCH] fix problem with procedure-chaperone, keywords, and proxy
 properties

---
 collects/racket/private/kw.rkt       | 13 +++++++++++--
 collects/tests/racket/chaperone.rktl | 15 +++++++++++++++
 2 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/collects/racket/private/kw.rkt b/collects/racket/private/kw.rkt
index 35bc9c3f50..1bbd20d305 100644
--- a/collects/racket/private/kw.rkt
+++ b/collects/racket/private/kw.rkt
@@ -1187,7 +1187,16 @@
 
   (define (do-chaperone-procedure is-proxy? chaperone-procedure name proc wrap-proc props)
     (if (or (not (keyword-procedure? proc))
-            (not (procedure? wrap-proc)))
+            (not (procedure? wrap-proc))
+            ;; if any bad prop, let `chaperone-procedure' complain
+            (let loop ([props props])
+              (cond
+               [(null? props) #f]
+               [(proxy-property? (car props))
+                (let ([props (cdr props)])
+                  (or (null? props)
+                      (loop (cdr props))))]
+               [else #t])))
         (apply chaperone-procedure proc wrap-proc props)
         (let-values ([(a) (procedure-arity proc)]
                      [(b) (procedure-arity wrap-proc)]
@@ -1317,5 +1326,5 @@
                 new-proc
                 (apply chaperone-struct new-proc 
                        ;; chaperone-struct insists on having at least one selector:
-                       keyword-procedure-allowed values
+                       keyword-procedure-allowed (lambda (s v) v)
                        props)))))))
diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl
index 4dbcfa5e3d..f2c1f33079 100644
--- a/collects/tests/racket/chaperone.rktl
+++ b/collects/tests/racket/chaperone.rktl
@@ -1131,6 +1131,21 @@
   (test #f equal? h2 f1)
   (test #f equal? h3 f1))
   
+;; ----------------------------------------
+
+;; A regression test mixing `procedure-rename',
+;; chaperones, and proxy properties:
+(let ()
+  (define (f #:key k) k)
+  (define null-checker
+    (make-keyword-procedure
+     (λ (kwds kwd-vals . args) (apply values kwd-vals args))
+     (λ args (apply values args))))
+  (define-values (proxy-prop:p p? p-ref) (make-proxy-property 'p))
+  (define new-f
+    (chaperone-procedure f null-checker proxy-prop:p #t))
+  
+  (test #t procedure? (procedure-rename new-f 'g)))
 
 ;; ----------------------------------------