From 4993e26b0a459e00d9e7cc2630c6ae74876c20eb Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 4 Jul 2008 20:22:33 +0000
Subject: [PATCH] PR 9442

svn: r10603
---
 collects/drscheme/private/main.ss         |  2 +-
 collects/scheme/private/contract-arrow.ss | 10 +++++++---
 collects/tests/mzscheme/contract-test.ss  | 13 +++++++++++++
 3 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss
index bac906ae27..3102343854 100644
--- a/collects/drscheme/private/main.ss
+++ b/collects/drscheme/private/main.ss
@@ -180,7 +180,7 @@
 
 (preferences:set-default 
  'drscheme:keybindings-window-size
- (cons 200 400)
+ (cons 400 600)
  (λ (x) (and (pair? x)
              (number? (car x))
              (number? (cdr x)))))
diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss
index 330e9a67ff..7dc86ea518 100644
--- a/collects/scheme/private/contract-arrow.ss
+++ b/collects/scheme/private/contract-arrow.ss
@@ -55,9 +55,13 @@ v4 todo:
                 (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
                   (λ (val)
                     (if (procedure? val)
-                        (λ args
-                          (let-values ([(res-x ...) (apply val args)])
-                            (values (p-app-x res-x) ...)))
+                        (make-keyword-procedure
+                         (λ (kwds kwd-vals . args)
+                           (let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)])
+                             (values (p-app-x res-x) ...)))
+                         (λ args
+                           (let-values ([(res-x ...) (apply val args)])
+                             (values (p-app-x res-x) ...))))
                         (raise-contract-error val
                                               src-info
                                               pos-blame
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 6468b4c8ce..270844d5ba 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -1914,6 +1914,19 @@
      10 +)
    55)
   
+  (test/spec-passed/result
+   'unconstrained-domain->6
+   ((contract (unconstrained-domain-> any/c)
+              (λ (#:key k) k)
+              'pos
+              'neg)
+    #:key 1)
+   1)
+  
+  (test/pos-blame
+   'unconstrained-domain->7
+   '((contract (unconstrained-domain-> number?) (λ (#:x x) x) 'pos 'neg) #:x #f))
+  
 ;                              
 ;                              
 ;