From 0ddfa81da3423d03b56c1a784d3b00be02fae14e Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 11 Jun 2010 17:28:59 -0400
Subject: [PATCH] Convert unconstrained-domain-> to chaperones.

original commit: 05e714881d95f2347bd71899acc20f95d726e7cc
---
 collects/mzlib/private/contract-arrow.rkt | 41 ++++++++++++++---------
 1 file changed, 26 insertions(+), 15 deletions(-)

diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt
index 74af99a..dd62436 100644
--- a/collects/mzlib/private/contract-arrow.rkt
+++ b/collects/mzlib/private/contract-arrow.rkt
@@ -35,22 +35,33 @@
                    [(res-x ...) (generate-temporaries #'(rngs ...))])
        #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
            (let ([proj-x (contract-projection rngs-x)] ...)
-             (define ctc
-               (make-contract
-                #:name
-                (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
-                #:projection
-                (λ (blame)
-                  (let ([p-app-x (proj-x blame)] ...)
-                    (λ (val)
-                      (if (procedure? val)
-                          (make-contracted-function
+             (define name
+               (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
+             (define (proj wrapper)
+               (λ (blame)
+                 (let* ([p-app-x (proj-x blame)] ...
+                        [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
+                   (λ (val)
+                     (if (procedure? val)
+                         (wrapper
+                          val
+                          (make-keyword-procedure
+                           (λ (kwds kwd-vals . args)
+                             (apply values res-checker kwd-vals args))
                            (λ args
-                             (let-values ([(res-x ...) (apply val args)])
-                               (values (p-app-x res-x) ...)))
-                           ctc)
-                          (raise-blame-error blame val "expected a procedure")))))
-                #:first-order procedure?))
+                             (apply values res-checker args)))
+                          proxy-prop:contracted ctc)
+                         (raise-blame-error blame val "expected a procedure"))))))
+             (define ctc
+               (if (and (chaperone-contract? rngs-x) ...)
+                   (make-chaperone-contract
+                    #:name name
+                    #:projection (proj chaperone-procedure)
+                    #:first-order procedure?)
+                   (make-contract
+                    #:name name
+                    #:projection (proj proxy-procedure)
+                    #:first-order procedure?)))
              ctc)))]))
 
 (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)