From baffeea2b4f9f572439c05ffc943120da1146da9 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 1 Nov 2008 19:55:21 +0000
Subject: [PATCH] drschemes scheme mode now sets the default extension for
 files to .ss

svn: r12213
---
 collects/framework/private/finder.ss | 28 +++++++++++++---------------
 collects/framework/private/mode.ss   |  4 +++-
 collects/framework/private/scheme.ss | 21 ++++++++-------------
 3 files changed, 24 insertions(+), 29 deletions(-)

diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss
index e8f0bad924..c899505dcc 100644
--- a/collects/framework/private/finder.ss
+++ b/collects/framework/private/finder.ss
@@ -4,9 +4,7 @@
            "sig.ss"
            "../preferences.ss"
            mred/mred-sig
-           mzlib/string
-           scheme/path
-           mzlib/etc)
+           scheme/path)
   
   
   (import mred^
@@ -33,13 +31,13 @@
   ;; dialog wrappers
   
   (define (*put-file style)
-    (opt-lambda ([name #f]
-                 [directory #f]
-                 [replace? #f]
-                 [prompt (string-constant select-file)]
-                 [filter #f]
-                 [filter-msg (string-constant file-wrong-form)]
-                 [parent-win (dialog-parent-parameter)])
+    (lambda ([name #f]
+             [directory #f]
+             [replace? #f]
+             [prompt (string-constant select-file)]
+             [filter #f]
+             [filter-msg (string-constant file-wrong-form)]
+             [parent-win (dialog-parent-parameter)])
       (let* ([directory (if (and (not directory) (string? name))
                             (path-only name)
                             directory)]
@@ -63,11 +61,11 @@
                  [else f]))))))
   
   (define (*get-file style)
-    (opt-lambda ([directory #f]
-                 [prompt (string-constant select-file)]
-                 [filter #f]
-                 [filter-msg (string-constant file-wrong-form)]
-                 [parent-win (dialog-parent-parameter)])
+    (lambda ([directory #f]
+             [prompt (string-constant select-file)]
+             [filter #f]
+             [filter-msg (string-constant file-wrong-form)]
+             [parent-win (dialog-parent-parameter)])
       (let ([f (get-file prompt parent-win directory #f #f style)])
         (and f (or (not filter) (filter-match? filter f filter-msg))
              (let ([f (normalize-path f)])
diff --git a/collects/framework/private/mode.ss b/collects/framework/private/mode.ss
index 1304dbea64..416caf6dcb 100644
--- a/collects/framework/private/mode.ss
+++ b/collects/framework/private/mode.ss
@@ -50,7 +50,9 @@
           (augment #t can-set-size-constraint? ())
           (override can-do-edit-operation? (op) (op recursive?))
           (augment #t can-load-file? (filename format))
-          (augment #t can-save-file? (filename format)))]))
+          (augment #t can-save-file? (filename format))
+          
+          (override put-file (directory default-name)))]))
 
 (define-unit mode@
   (import)
diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index 18b077e052..f3e8c76557 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -22,7 +22,8 @@
         [prefix comment-box: framework:comment-box^]
         [prefix mode: framework:mode^]
         [prefix color: framework:color^]
-        [prefix color-prefs: framework:color-prefs^])
+        [prefix color-prefs: framework:color-prefs^]
+        [prefix finder: framework:finder^])
 
 (export (rename framework:scheme^
                 [-text-mode<%> text-mode<%>]
@@ -1180,6 +1181,11 @@
           (else
            (values lexeme type paren start end)))))
     
+    (define/override (put-file text sup directory default-name)
+      (parameterize ([finder:default-extension "ss"])
+        ;; don't call the surrogate's super, since it sets the default extension
+        (sup directory default-name)))
+    
     (super-new (get-token (lambda (in) (scheme-lexer-wrapper in)))
                (token-sym->style short-sym->style-name)
                (matches '((|(| |)|)
@@ -1219,18 +1225,7 @@
 (define text-mode% (text-mode-mixin color:text-mode%))
 
 
-;;                                 ;;                                        
-;                                  ;                                        
-;                                  ;                                        
-;;;    ;;;   ; ;;    ;;;  ;;; ;    ;;;          ;  ;;   ;;;  ;;; ;;;;;; ;   ;;;;  ; ;;;  
-;   ;  ;   ;  ;;  ;  ;   ;  ; ; ;  ;   ;         ; ;    ;   ;  ;   ;  ; ; ;      ;  ;   ; 
-;;;   ;      ;   ;  ;;;;;  ; ; ;  ;;;;;         ;;     ;;;;;  ;   ;  ; ; ;   ;;;;  ;   ; 
-;  ;      ;   ;  ;      ; ; ;  ;             ; ;    ;       ; ;   ; ; ;  ;   ;  ;   ; 
-;   ;  ;   ;  ;   ;  ;   ;  ; ; ;  ;   ;         ;  ;   ;   ;   ;;;   ; ; ;  ;   ;  ;   ; 
-;;;    ;;;  ;;; ;;;  ;;;  ;; ; ;;  ;;;         ;;   ;;  ;;;     ;   ;; ; ;;  ;;; ; ;;;;  
-;                  ;     
-;                  ;     
-;;                  ;;;    
+
 (define (setup-keymap keymap)
   (let ([add-pos-function
          (λ (name call-method)